home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 10 / AACD 10.iso / AACD / Online / SpeakFreely / sfvod.pl < prev    next >
Text File  |  2000-05-16  |  17KB  |  502 lines
  1. #
  2. #               Speak Freely Voice on Demand Server
  3. #
  4.  
  5.     $host_timeout = 30;
  6.     $live = 0;
  7.     $lchild = -1;
  8.     $lwltell = -1;
  9.     $log = 0;
  10.     $verbose = 0;
  11.     $hexdump = 0;
  12.     $debug = 0;
  13.     $port = 3456;
  14.     $soundfile = "";
  15.     $moptions = "";
  16.     $program = "sfmike -a";
  17.  
  18.     @proto = ( "-vat ", "", "-rtp ", "" );
  19.     @protoName = ( "VAT", "Speak_Freely", "RTP", "Gibberish" );
  20.     @mname = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
  21.                "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
  22.  
  23.     $me = $0;
  24.     if (rindex($me, "/") >= 0) {
  25.         $me = substr($me, rindex($me, "/") + 1);
  26.     }
  27.  
  28.     #   Process command line arguments
  29.  
  30.     $arghhh = 1;
  31.     while (@ARGV) {
  32.         $arg = shift;
  33.         if (substr($arg, 0, 1) eq "-" & $arghhh) {
  34.  
  35.             #   An argument of a single dash terminates our processing
  36.             #   of arguments.  Any that remain are passed to sfmike.
  37.  
  38.             if (length($arg) == 1) {
  39.                 $arghhh = 0;
  40.                 next;
  41.             }
  42.             $opt = substr($arg, 1, 1);
  43.             $opt =~ tr/A-Z/a-z/;
  44.             $opa = substr($arg, 2);
  45.             if ($opt eq 'a') {        # -A  --  Live audio mode
  46.                 $live = 1;
  47.             } elsif ($opt eq 'd') {   # -D  --  Debug output
  48.                 $debug = 1;
  49.             } elsif ($opt eq 'l') {   # -Lfile  --  Log requests in file
  50.                 $log = 1;
  51.                 open(LOGFILE, ">>" . $opa);
  52.                 select(LOGFILE);
  53.                 $| = 1;
  54.                 select(stdout);
  55.             } elsif ($opt eq 'p') {   # -Pport  --  Listen on given port
  56.                 $port = $opa;
  57.             } elsif ($opt eq 'r') {   # -Rprog  --  Run "prog" to serve requests
  58.                 $program = $opa;
  59.             } elsif ($opt eq 't') {   # -Ttime  --  Time out hosts after time seconds
  60.                 $host_timeout = $opa;
  61.                 if ($host_timeout < 20) {
  62.                     print "Timeout (-t) must be at least 20 seconds.\n";
  63.                     exit;
  64.                 }
  65.             } elsif ($opt eq 'u' || $opt eq '?') {
  66.                 print "sfvod  --  Speak Freely voice on demand server.\n";
  67.                 if (defined $version) {
  68.                     print "           $version.\n"; 
  69.                 }
  70.                 print "Usage: sfvod [options] soundfile...\n";
  71.                 print "Options:\n";
  72.                 print "    -A         Send live audio\n";
  73.                 print "    -Lfile     Log requests in file\n";
  74.                 print "    -Pport     Listen on given port (default 3456)\n";
  75.                 print "    -Rprog     Run prog to process request (default sfmike)\n";
  76.                 print "    -Ttime     Time out inactive hosts after time seconds\n";
  77.                 print "    -U         Print this message\n";
  78.                 print "    -V         Show host connects and disconnects\n";
  79.                 print "    -X         Dump host addresses and packets in hex\n";
  80.                 print "    -          Pass subsequent options to sfmike\n";
  81.                 exit;
  82.             } elsif ($opt eq "v") {   # -V  --  Verbose output
  83.                 $verbose = 1;
  84.             } elsif ($opt eq "x") {   # -X  --  Hexadecimal dump
  85.                 $hexdump = 1;
  86.             }
  87.         } else {
  88.             if (substr($arg, 0, 1) eq "-") {
  89.                 if (length($moptions) > 0) {
  90.                     $moptions .= " ";
  91.                 }
  92.                 $moptions .= $arg;
  93.             } else {
  94.                 if (length($soundfile) > 0) {
  95.                     $soundfile .= " ";
  96.                 }
  97.                 $soundfile .= $arg;
  98.             }
  99.         }
  100.     }
  101.  
  102. #   $AF_INET = 2;                     # These can vary from system to
  103. #   $SOCK_DGRAM = 2;                  # system, so they're suppled by the Makefile
  104.     $EINTR = 4;                       # Interrupted system call status
  105.     $ECHILD = 10;                     # No children status
  106.     $sockaddr = 'S n a4 x8';
  107.     $protocol = getprotobyname('udp'); # We use UDP protocol
  108.     $WNOHANG = defined &WNOHANG ? &WNOHANG : 1;
  109.     $SIG{'CHLD'} = 'reaper';          # Register child process reaper
  110.  
  111.     if ($verbose) {
  112.         print "$me: listening on port $port.\n";
  113.     }
  114.  
  115.     #   Create a socket to listen on the control port and bind
  116.     #   it to the port number.
  117.  
  118.     $sock = pack($sockaddr, $AF_INET, $port + 1, "\0\0\0\0");
  119.     socket(S, $AF_INET, $SOCK_DGRAM, $protocol) || die "Error creating socket: $!";
  120.     bind(S, $sock) || die "Error binding socket: $!";
  121.     select(S);
  122.     $| = 1;
  123.     select(stdout);
  124.  
  125.     $SIG{'ALRM'} = 'tick';            # Register timeout handler
  126.     alarm(10);                        # Set timeout handler
  127.  
  128.     #   If SPEAKFREE_LWL_TELL is defined, fork a process to publish
  129.     #   our identity on the LWL server.
  130.  
  131.     if (defined($ENV{'SPEAKFREE_LWL_TELL'})) {
  132.         if (($lwltell = fork()) == 0) {
  133.             $SIG{'INT'} = 'killed';
  134.             $zexec = "sfspeaker -w$port";
  135.             if ($debug) {
  136.                 print("Exec: $zexec\n");
  137.             }
  138.             exec($zexec);
  139.             exit;
  140.         }
  141.     }
  142.  
  143.     $con = 1;
  144.     while (1) {
  145.  
  146.         #   Wait until a packet arrives from the control port.
  147.  
  148.         #   You might be wondering why we're doing a select()
  149.         #   here when we're only interested in waiting on a
  150.         #   single file discriptor.  Well, the reason is that
  151.         #   there's a stone bug in Perl 5.004 which causes the
  152.         #   first recv() after a signal was processed (hence using
  153.         #   the "restartable system call" mechanism) to return
  154.         #   the null string as the sender's address, notwithstanding
  155.         #   the fact that the data for the packet has been correcly
  156.         #   stored into the string argument.
  157.         #
  158.         #   If one uses select(), however, to block until a
  159.         #   packet is ready to recv(), the problem does not
  160.         #   occur.  So that's the way we'll do it.
  161.  
  162.         $rin = '';
  163.         vec($rin, fileno(S), 1) = 1;
  164.         $nfound = select($rout = $rin, undef, undef, undef);
  165.  
  166.         if ($nfound == 0) {
  167. #           &tick();
  168.             next;
  169.         }
  170.  
  171.         $addr = recv(S, $sockread, 512, 0);
  172.         if (!defined($addr)) {
  173.             if ($debug) {
  174.                 print("Recv error: $!\n");
  175.             }
  176.             if ($! == $EINTR || $! == $ECHILD) {
  177.                 if ($debug) {
  178.                     print(" ...ignoring\n");
  179.                 }
  180.                 next;
  181.             }
  182.             die "Error receiving from socket: $!";
  183.         }
  184.         if ($hexdump) {
  185.             printf("Address, length %d:\n", length($addr));
  186.             &hexdump($addr, '    ');
  187.         }
  188.         if (length($addr) < 16) {
  189.             if ($debug) {
  190.                 print("Recv: Void address\n");
  191.             }
  192.             next;
  193.         }
  194.         if ($hexdump) {
  195.             printf("Packet, length %d:\n", length($sockread));
  196.             &hexdump($sockread, '    ');
  197.         }
  198.         $pr = (ord($sockread) >> 6) & 3;  # Extract protocol from first byte
  199.         ($af, $rport, $inetaddr) = unpack($sockaddr, $addr);
  200.         @inetaddr = unpack('C4', $inetaddr);
  201.         #   Build dotted IP address to pass to sfmike
  202.         $IPaddress = "$inetaddr[0].$inetaddr[1].$inetaddr[2].$inetaddr[3]";
  203.  
  204.         if (defined $hosts{$IPaddress}) {
  205.  
  206.             #   Check for a BYE packet
  207.  
  208.             $isbye = 0;
  209.             if ($pr == 0) {
  210.                 if (ord(substr($sockread, 1, 1)) == 2) {
  211.                     $isbye = 1;
  212.                 }
  213.             } else {
  214.                 $isbye = &isRTCPbye;
  215.             }
  216.             if ($isbye) {
  217.                 if ($debug) {
  218.                     print "BYE received from $IPaddress\n";
  219.                 }
  220.  
  221.                 #   If child process still active, kill it.  This allows
  222.                 #   the user to end the transmission at any time by
  223.                 #   disconnecting.
  224.  
  225.                 if (!$live && ($timer{$hosts{$IPaddress}} == 0)) {
  226.                     if ($debug) {
  227.                         printf "Killing process $hosts{$IPaddress}\n";
  228.                     }
  229.                     kill('INT', $hosts{$IPaddress});
  230.                 }
  231.                 &closeout($IPaddress);
  232.                 &updlive();
  233.                 if ($verbose) {
  234.                     print "$me: $IPaddress bye.\n";
  235.                 }
  236.                 next;
  237.             }
  238.  
  239.             #   If we're in the process of timing out this connection,
  240.             #   reset the timer every time we receive a new packet.
  241.             #   This keeps us from timing out the host and inadvertently
  242.             #   restarting the transmission.
  243.  
  244.             if ($timer{$hosts{$IPaddress}} != 0) {
  245.                 $timer{$hosts{$IPaddress}} = time();
  246.             }
  247.             next;
  248.         }
  249.  
  250.         #   Only look up the host name if we're in verbose mode or
  251.         #   writing a log file.  Host lookups can take a while and
  252.         #   there's no need to create the extra network traffic unless
  253.         #   we really need the host name.
  254.  
  255.         if ($log || $verbose) {
  256.             $name = "";
  257.             ($name, $aliases, $length, @addrs) = gethostbyaddr($inetaddr,
  258.                 length($inetaddr));
  259.             if (length($name) == 0) {
  260.                 $name = $IPaddress;
  261.             }
  262.             if ($verbose) {
  263.                 print "$me: $name ($IPaddress) $protoName[$pr] connect.\n";
  264.             }
  265.  
  266.             #   Write a log file entry in a format strongly resembling
  267.             #   NCSA Common HTTPD log file format.  We always use GMT
  268.             #   and zero for the length of the transmission.  Suitable
  269.             #   ugly hacks could remove these limitations.  In place
  270.             #   of "HTTP" we show the protocol we used for the transmission.
  271.  
  272.             if ($log) {
  273.                 ($ss, $mm, $hh, $mday, $mon, $yy, $wd, $yd, $isdst) =
  274.                     gmtime(time());
  275.                 print LOGFILE 
  276.                     sprintf("%s - - [%02d/%s/%d:%02d:%02d:%02d +0000] \"GET %s %s/1.0\" 200 0\n",
  277.                         $name,
  278.                         $mday, $mname[$mon], $yy + 1900, $hh, $mm, $ss,
  279.                         $soundfile, $protoName[$pr]);
  280.             }
  281.         }
  282.  
  283.         #   Now we're actually ready to do something.  Fork a child
  284.         #   process and invoke sfspeaker (or whatever program the user
  285.         #   specified with the "-r" option) to play whatever was
  286.         #   specified on our command line.  Note that we include
  287.         #   the protocol of the request we received on the command
  288.         #   line in order to respond in the same protocol as that
  289.         #   of the request.
  290.  
  291.         if (!$live && (($child = fork()) == 0)) {
  292.             $SIG{'INT'} = 'killed';
  293.             $zexec = "$program $proto[$pr] $moptions -p$IPaddress/$port $soundfile";
  294.             if ($debug) {
  295.                 print("Exec: $zexec\n");
  296.             }
  297.             exec($zexec);
  298.             exit;
  299.         }
  300.         $con++;
  301.  
  302.         #   Save information about the request in progress:
  303.         #
  304.         #   $children{$child_process_pid} = IP address of host
  305.         #
  306.         #   $timer{$child_process_pid}    = 0 while transmission is
  307.         #                                   underway.  When the child process
  308.         #                                   exits, this is set to the time
  309.         #                                   the process exited, and is updated
  310.         #                                   every time we get another ID
  311.         #                                   packet from the host.  This is
  312.         #                                   used by the timer to timeout
  313.         #                                   hosts that go away without sending
  314.         #                                   a BYE.
  315.         #
  316.         #   $hosts{$IPaddress}            = Child process serving the request
  317.         #                                   from that IP address.
  318.  
  319.         $children{$child} = $IPaddress;
  320.         $timer{$child} = 0;
  321.         $hosts{$IPaddress} = $child;
  322.         &updlive;
  323.     }
  324.  
  325. #   &closeout(ip)  --  Close out host with given IP address
  326.  
  327. sub closeout {
  328.     local($h) = $_[0];
  329.     local($ch) = $hosts{$h};
  330.     delete $children{$ch};
  331.     delete $timer{$ch};
  332.     delete $hosts{$h};
  333. }
  334.  
  335. #   &dumpstat  --  Dump state arrays
  336.  
  337. sub dumpstat {
  338.     print "Children:\n"; foreach $s (keys(%children)) { print "  $s $children{$s}\n"; }
  339.     print "Hosts:\n"; foreach $s (keys(%hosts)) { print "  $s $hosts{$s}\n"; }
  340.     print "Timer:\n"; foreach $s (keys(%timer)) { print "  $s $timer{$s}\n"; }
  341. }
  342.  
  343. #   &killed  --  Catch interrupt when user disconnects before
  344. #                we're done playing the sound.
  345.  
  346. sub killed {
  347.     exit;
  348. }
  349.  
  350. #   &reaper  --  Catch terminating child processes and start
  351. #                the inactivity timeout running.
  352.  
  353. sub reaper {
  354.     local($pid);
  355.  
  356.     if ($debug) {
  357.         print "Reaper...\n";
  358.     }
  359.     while (1) {
  360.         $pid = waitpid(-1, $WNOHANG);
  361.         if ($debug) {
  362.             print "   Reaped process $pid\n";
  363.         }
  364.         last if ($pid < 1);
  365.         if ($live && $pid == $lchild) {
  366.             $lchild = -1;
  367.             &updlive();
  368.         } elsif (defined $timer{$pid}) {
  369.             $timer{$pid} = time();
  370.         }
  371.     }
  372.     if ($debug) {
  373.         print "Reaped.\n";
  374.     }
  375.     $SIG{'CHLD'} = 'reaper';          # Reset child process reaper
  376. }
  377.  
  378. #   &tick  --  Scan the list of open connections and check for any
  379. #              which haven't sent an identity packet in $host_timeout
  380. #              seconds.  If that's the case, terminate the connection
  381. #              (rendering it eligible for re-connection if and when we
  382. #              see another packet from this host).
  383.  
  384. sub tick {
  385.     local($t, $h, $l);
  386.  
  387.     if ($debug) {
  388.         print("Tick...\n");
  389.     }
  390.     $t = time();
  391.     foreach $h (keys(%children)) {
  392.         if ($timer{$h} != 0) {
  393.             $l = time() - $timer{$h};
  394.             if ($l > $host_timeout) {
  395.                 &closeout($children{$h});
  396.                 &updlive();
  397.                 if ($verbose) {
  398.                     print "$me: $IPaddress timeout.\n";
  399.                 }
  400.             }
  401.         }
  402.     }
  403.     alarm(10);
  404.     $SIG{'ALRM'} = 'tick';            # Reset timeout handler
  405. }
  406.  
  407. #   &isRTCPbye  --  See if a received packet is an RTCP BYE
  408.  
  409. sub isRTCPbye {
  410.     local($p0, $p1, $len, $n, $end, $sawbye);
  411.  
  412.     $sawbye = 0;
  413.     $len = length($sockread);
  414.     $p0 = ord($sockread);
  415.     $p1 = ord(substr($sockread, 1, 1));
  416.     if ((($p0 >> 6) == 2 || ($p0 >> 6) == 1) &&
  417.         (($p0 & 0x20) == 0) &&
  418.         (($p1 == 200) || ($p1 == 201))) {
  419.     }
  420.  
  421.     $n = 0;
  422.     do {
  423.         if (ord(substr($sockread, $n + 1, 1)) == 203) {
  424.             $sawbye = 1;
  425.         }
  426.         $n += (((ord(substr($sockread, $n + 2, 1)) * 256) +
  427.                  ord(substr($sockread, $n + 3, 1))) + 1) * 4;
  428.     } while (($n < $len) && ((ord(substr($sockread, $n, 1)) >> 6) == 2));
  429.     $n == $len && $sawbye;
  430. }
  431.  
  432. #   &updlive  --  Update list of active live audio destinations
  433.  
  434. sub updlive {
  435.     local($a, $b, $zexec);
  436.  
  437.     if ($live) {
  438.         if ($lchild >= 0) {
  439.             kill('INT', $lchild);
  440.         } else {
  441.             $a = "";
  442.             foreach $b (keys(%hosts)) {
  443.                 if (length($a) > 0) {
  444.                     $a .= " ";
  445.                 }
  446.                 $a .= "-p$b/$port";
  447.             }
  448.             if (length($a) > 0) {
  449.                 if (verbose) {
  450.                     print "$me: sending to $a.\n";
  451.                 }
  452.                 if (($lchild = fork()) == 0) {
  453.                     $SIG{'INT'} = 'lkilled';
  454.                     $zexec = "$program $moptions $a";
  455.                     if ($debug) {
  456.                         print("Exec: $zexec\n");
  457.                     }
  458.                     exec($zexec);
  459.                     exit;
  460.                 }
  461.             } else {
  462.                 if (verbose) {
  463.                     print "$me: idle.\n";
  464.                 }
  465.             }
  466.         }
  467.     }
  468. }
  469.  
  470. #   &lkilled  --  Catch interrupt when live audio player terminates
  471.  
  472. sub lkilled {
  473.     exit;
  474. }
  475.  
  476. #   &hexdump  --  Dump contents of string in hexadecimal
  477.  
  478. sub hexdump {
  479.     local($d, $xdp) = @_;
  480.     local($adr) = 0;
  481.     local($l) = 0;
  482.  
  483.     while (length($d) > 0) {
  484.         if ($l == 0) {
  485.             printf("%s%04X: ", $xdp, $adr);
  486.         }
  487.         if ($l == 8) {
  488.             printf(" :");
  489.         }
  490.         printf(" %02X", unpack('C', $d));
  491.         $d = substr($d, 1);
  492.         $adr++;
  493.         $l = ($l + 1) % 16;
  494.         if ($l == 0) {
  495.             print("\n");
  496.         }
  497.     }
  498.     if ($l > 0) {
  499.         print("\n");
  500.     }
  501. }
  502.